home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / More classes / Sets < prev    next >
Text File  |  1991-09-09  |  2KB  |  89 lines
  1. \ Some experimentation.
  2.  
  3. : ET!        immediate
  4.     $ 201E w,                \    POP.L    D0
  5.     $ 41BC w,                \    CHK    #nn,D0
  6.     w,                    \        (nn)
  7.     $ 1480 w,                \    MOVE.B    D0,(A2)
  8.     ;
  9.  
  10.     0    value    X
  11.     0    value    LO
  12.     0    value    HI
  13.  
  14. : (DO_ET)
  15.     typecnt 1 -  -> x
  16.     " :m SIZE: [ x ] lit ;m"    evaluate
  17.     " :m PUT: [ x ] et! ;m"    evaluate  ;
  18.  
  19. ' (do_ET) -> do_ET
  20.  
  21.  
  22. :class    ENUM-TYPE    super{  byte  }        \ Generic supertype for all enumerated
  23.                         \ types.
  24.  
  25. :m  GET:        ^base c@   ;m
  26. :m  ->:        chksame  c@  ^base c!   ;m
  27.  
  28. ;class
  29.  
  30.  
  31. : IS_RANGE
  32.     -> hi  -> lo   hi lo -  -> x
  33.     " :m RANGE:    [ lo ] lit [ hi ] lit ;m"    evaluate
  34.     " :m PUT:    [ lo ] lit -  [ x ] et! ;m"    evaluate
  35.     " :m GET:    ^base c@  [ lo ] lit + ;m"    evaluate   ;
  36.  
  37.  
  38. :class    RANGE    super{  byte  }
  39.  
  40. :m  ->:    chksame  c@  ^base c!   ;m
  41.  
  42. ;class
  43.  
  44.  
  45.     0    value    SZ
  46.     0    value    LN
  47.  
  48. : ELEMENT_IS
  49.     " SIZE:" here place  here hash
  50.     '                    \ ^class
  51.     findm  nip  execute  -> sz
  52.     sz 1-  3 >>  1+  -> ln
  53.     ln  ^class dfa w+!            \ Allocate the space
  54.                         \ Now we define the methods:
  55.     " :m SIZE: [ sz ] lit ;m"    evaluate
  56.     " :m LEN:  [ ln ] lit ;m"    evaluate  ;
  57.  
  58.  
  59. :class  SET    super{  object  }
  60.  
  61. :m  +:    ^base swap bset   ;m
  62. :m  -:    ^base swap breset   ;m
  63.  
  64. :m  IN?:    inline{ obj swap btest}
  65.     ^base swap btest   ;m
  66.  
  67. :m CLASSINIT:
  68.     len: [self]
  69.     for   0 ^base i +  c!  next  ;m
  70.  
  71. ;class
  72.  
  73. \ endload
  74.  
  75. :class    DAY    super{  enum-type  }
  76.     type{ sunday monday tuesday wednesday thursday friday saturday }
  77. ;class
  78.  
  79. :class    DAYS    super{ set }    element_is  day
  80. ;class
  81.  
  82. day    TODAY
  83. day    YESTERDAY
  84. days    WEEKEND    saturday +: weekend   sunday +: weekend
  85.  
  86. :class    RRR    super{ range }    100 200 is_range
  87. ;class
  88.  
  89.